home *** CD-ROM | disk | FTP | other *** search
/ L' Effet Pommier 3 / L'Effet Pommier - Volume 03.iso / Programmation / Alpha ƒ / Tcl / SystemCode / tcl.tcl < prev    next >
Text File  |  1996-01-22  |  8KB  |  286 lines
  1.  
  2. # The menu.
  3. menu -n $tclMenu -p tclMenuProc {
  4.     "/Z<O<UtraceTclProc╔"
  5.     "/D<O<UdumpTraces"
  6.     "(-"
  7.     "rebuildTclIndices"
  8.     "(-"
  9.     "<U/PprocDefinition"
  10.     "getVarValue╔"
  11. }
  12. proc tclMenu {} {}
  13.  
  14. newModeVar Tcl prefixString {# } 0
  15. newModeVar Tcl wordWrap {0} 1
  16. newModeVar Tcl funcExpr {^proc *([+-a-zA-Z0-9]+)} 0
  17. newModeVar Tcl wordBreak {(\$)?[a-zA-Z0-9_]+} 0
  18. newModeVar Tcl wordBreakPreface {([^a-zA-Z0-9_\$]|.\$)} 0
  19. newModeVar Tcl elecLBrace    1    1
  20. newModeVar Tcl elecRBrace    1    1
  21. newModeVar Tcl elecReturn    1    1
  22. newModeVar Tcl autoMark    0    1
  23. newModeVar Tcl electricTab 1 1
  24. newModeVar Tcl stringColor    green    0
  25. newModeVar Tcl commentColor    red    0
  26. newModeVar Tcl keywordColor    blue    0
  27.  
  28. set tclKeyWords {
  29.     then append array break case catch cd close concat continue elseif else eof 
  30.     error eval exec exit expr file flush foreach format for gets global glob 
  31.     history if incr info join lappend library lindex linsert list llength 
  32.     lrange lreplace lsearch lsort open pid proc puts pwd read regexp regsub 
  33.     rename return scancontext scan seek set source split string switch tell 
  34.     time trace unknown unset uplevel upvar while
  35.     
  36.     menu
  37. }
  38. if {[info exists Tclwords]} {set tclKeyWords [concat $tclKeyWords $Tclwords]}
  39. regModeKeywords -e {#} -c $TclmodeVars(commentColor) -k $TclmodeVars(keywordColor) Tcl $tclKeyWords -s $TclmodeVars(stringColor)
  40. unset tclKeyWords
  41.  
  42. #================================================================================
  43.  
  44. proc electricTclLeft {} {
  45.         global TclmodeVars
  46.         
  47.         if { [isSelection] } { deleteSelection }
  48.         if { [literalChar] } { insertText "\{"; return }
  49.         set pat {\}[ \t\r]*(else(if)?)[ \t\r]*}
  50.         if { !$TclmodeVars(elecLBrace) || \
  51.              (([lookAt [getPos]] != "\r") && ([getPos] != [maxPos])) || \
  52.              [catch {search -s -f 0 -r 1 "\}" [getPos]} res] || \
  53.              ![regexp $pat [getText [lindex $res 0] [getPos]] dum word] } {
  54.                 insertText "\{"
  55.                 return
  56.         }
  57.         replaceText [lindex $res 0] [getPos] "\} $word \{\r"
  58.         indentLine
  59.         if { $word == "elseif" } {
  60.                 previousLine
  61.                 endOfLine
  62.         }
  63. }
  64. bind '\{' <s> electricTclLeft Tcl
  65.  
  66.  
  67. proc electricTclRight {} {
  68.         global TclmodeVars
  69.                 
  70.         if { [isSelection] } { deleteSelection }
  71.         if { [literalChar] } { insertText "\}"; return }
  72.         if { !$TclmodeVars(elecRBrace) || \
  73.              [regexp {[^ \t]} [getText [lineStart [getPos]] [getPos]]] } {
  74.                 insertText "\}"
  75.                 blink [matchIt "\}" [expr [getPos] - 2]]
  76.                 return
  77.         }
  78.         set start [lineStart [getPos]]
  79.         insertText "\}"
  80.         backwardChar
  81.         indentLine
  82.         endOfLine
  83.         tclCarriageReturn
  84.         blink [matchIt "\}" $start]
  85. }
  86. bind '\}' <s> electricTclRight Tcl
  87.     
  88.  
  89. proc tclCarriageReturn {} {
  90.     global TclmodeVars
  91.     
  92.     insertText "\r"
  93.     if {$TclmodeVars(elecReturn)} {
  94.         indentLine
  95.     }
  96. }
  97. bind '\r' tclCarriageReturn Tcl
  98.  
  99.  
  100.  
  101. proc rebuildTclIndices {} {
  102.     global auto_path
  103.     set d [pwd]
  104.     # do we really need the next line? Alpha's original uses it.
  105.     cd
  106.     foreach dir $auto_path {
  107.         # if directory exists
  108.         if { ![catch { cd $dir } ] } {
  109.             # if there are any files
  110.             if { ![catch { glob *.*tcl } ] } {
  111.                 message "Building [file tail $dir] index╔"
  112.                 
  113.                 # if the '[incr tcl]' version exists, use that
  114.                 # use 'catch' also in case directory is write-protected
  115.                 if [catch { itcl_mkindex : *.*tcl } ] {
  116.                     # else try the normal one
  117.                     catch { auto_mkindex : *.*tcl }
  118.                 }
  119.             }
  120.         }
  121.     }
  122.     # redo the auto-mode-file connections (see "smarterSource.tcl")
  123.     message "Building the mode-file dependency array"
  124.     catch {autoModeFiles}
  125.     message ""
  126.     cd $d
  127. }
  128.  
  129.  
  130. proc tclMenuProc {menu item} {
  131.     global tclColoring
  132.  
  133.     eval $item
  134. }
  135.  
  136.  
  137. #===========================================================================
  138. # Debug a Tcl procedure.
  139. #===========================================================================
  140.  
  141. # Alpha TCL programming mode
  142.  
  143. proc traceTclProc {} {
  144.     global tclMenu
  145.     if {[llength [traceFunc status]]>2} {
  146.         catch {markMenuItem $tclMenu {traceTclProc╔} off}
  147.         catch {enableMenuItem $tclMenu dumpTraces off}
  148.         if {[string length [set data [traceDump]]]} {
  149.             if {[askyesno "Dump traces?"] == "yes"} {
  150.                 dumpTraces [string trimright [lindex [traceFunc status] 3] {,}] $data
  151.                 setWinInfo dirty 0
  152.             }
  153.         }
  154.         traceFunc off
  155.         message "Tracing off."
  156.         return
  157.     }
  158.     if {[llength [winNames]] && [string length [set sel [getSelect]]]} {
  159.         set func [listpick -L $sel -p {Func Name:} [lsort -ignore [info procs]]]
  160.     } else {
  161.         set func [listpick -p {Func Name:} [lsort -ignore [info procs]]]
  162.     }
  163.     if {![string length $func]} return
  164.     traceFunc on $func ""
  165.     catch {markMenuItem $tclMenu {traceTclProc╔} on}
  166.     catch {enableMenuItem $tclMenu dumpTraces on}
  167.     message "Tracing '$func'╔"
  168. }
  169.  
  170.  
  171. proc dumpTraces {{name ""} {data ""}} {
  172.     if {![string length $name]} {
  173.         set name [string trimright [lindex [traceFunc status] 3] {,}]
  174.     }
  175.     if {![string length $data]} {
  176.         set data [traceDump]
  177.     }
  178.     
  179.     if {![string length $data]} {
  180.         message "Trace buffer empty"
  181.     } else {
  182.         new -n "* Trace '$name' *"
  183.         insertText $data
  184.         setWinInfo dirty 0
  185.         goto 0 
  186.     }
  187. }
  188.  
  189. proc setTclMode {} {
  190.     changeMode "Tcl"
  191. }
  192.  
  193. #================================================================================
  194. proc TclMarkFile {} {
  195.     set end [maxPos]
  196.     set pos 0
  197.     set l {}
  198.     set markExpr {^[ \t]*(itcl_class|proc|method)}
  199.     set class ""
  200.     while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
  201.         set start [lindex $res 0]
  202.         set end [nextLineStart $start]
  203.         set t [getText $start $end]
  204.         switch [lindex $t 0] {
  205.             "proc" { set text [lindex $t 1] }
  206.             "method" { set text ${class}::[lindex $t 1] }
  207.             "itcl_class" { 
  208.                 set class [lindex $t 1]
  209.                 set text "${class} 000" 
  210.             }
  211.         }
  212.         set pos $end
  213.         set inds($text) [lineStart [expr $start - 1]]
  214.     }
  215.  
  216.     set already ""
  217.     
  218.     if {[info exists inds]} {
  219.         foreach f [lsort -ignore [array names inds]] {
  220.             set next [nextLineStart $inds($f)]
  221.             if { [string first "::" $f] != -1 } {
  222.                 set ff " :: [lindex [split $f "::"] 2]"
  223.             } elseif { [string first "000" $f] != -1 } {
  224.                 set ff "Class '[lindex $f 0]'"
  225.             } else {
  226.                 set ff $f
  227.             }
  228.             while { [lsearch -exact $already $ff] != -1 } {
  229.                 set ff "$ff "
  230.             }
  231.             lappend already $ff
  232.             setNamedMark $ff $inds($f) $next $next
  233.         }
  234.     }
  235. }
  236.  
  237. proc dummyTcl {} {}
  238.  
  239. #===============================================================================
  240. proc TclDblClick {from to shift option control} {
  241.     global HOME auto_index
  242.     
  243.     select $from $to
  244.     set text [getSelect]
  245.  
  246.     # Is it a loaded proc?
  247.     if {[info exists "auto_index($text)"]} {
  248.         editMark "$auto_index($text)" $text
  249.         return
  250.     }
  251.     # Is it a built-in Alpha command?
  252.     set lines [grep "^Ñ $text " "$HOME:Help:Alpha Commands"]
  253.     if {[string length $lines]} {
  254.         editMark "$HOME:Help:Alpha Commands" $text
  255.         setWinInfo read-only 1
  256.         return
  257.     }
  258.     # Is it a core Tcl command?
  259.     set lines [grep "^     $text -" "$HOME:Help:Tcl Commands"]
  260.     if {[string length $lines]} {
  261.         editMark "$HOME:Help:Tcl Commands" $text
  262.         setWinInfo read-only 1
  263.         return
  264.     }
  265.     # Is it a global variable?
  266.      if {[llength [info globals [string trimleft $text {$}]]]==1} {
  267.         showVarValue [string trimleft $text {$}]
  268.         return
  269.     }
  270.     message "No docs $shift $control $option"
  271. }
  272.  
  273. proc procDefinition {} {
  274.     global auto_index auto_help 
  275.     
  276.     if {[llength [winNames]] && [string length [set sel [getSelect]]]} {
  277.         set func [listpick -L $sel -p {Proc?} [lsort -ignore [array names auto_index]]]
  278.     } else {
  279.         set func [listpick -p {Proc?} [lsort -ignore [array names auto_index]]]
  280.     }
  281.  
  282.     editMark "$auto_index($func)" $func
  283. }
  284.  
  285. #===============================================================================
  286.